home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / mawk10.zip / BI_FUNCT.C < prev    next >
C/C++ Source or Header  |  1991-10-05  |  22KB  |  895 lines
  1.  
  2. /********************************************
  3. bi_funct.c
  4. copyright 1991, Michael D. Brennan
  5.  
  6. This is a source file for mawk, an implementation of
  7. the AWK programming language.
  8.  
  9. Mawk is distributed without warranty under the terms of
  10. the GNU General Public License, version 2, 1991.
  11. ********************************************/
  12.  
  13. /* $Log:    bi_funct.c,v $
  14.  * Revision 3.7.1.1  91/09/14  17:22:38  brennan
  15.  * VERSION 1.0
  16.  * 
  17.  * Revision 3.7  91/08/19  10:46:13  brennan
  18.  * fixed small bozo in bi_substr
  19.  * 
  20.  * Revision 3.6  91/08/13  06:50:47  brennan
  21.  * VERSION .9994
  22.  * 
  23.  * Revision 3.5  91/08/03  05:03:50  brennan
  24.  * set RLENGTH to -1 on no match
  25.  * 
  26.  * Revision 3.4  91/07/22  12:31:15  brennan
  27.  * changed how srand() handles strings
  28.  * 
  29.  * Revision 3.3  91/06/28  04:16:03  brennan
  30.  * VERSION 0.999
  31.  * 
  32.  * Revision 3.2  91/06/28  04:14:11  brennan
  33.  * srand() now returns previous seed (posix).
  34.  * 
  35.  * Revision 3.1  91/06/08  06:14:38  brennan
  36.  * VERSION 0.995
  37.  * 
  38.  * Revision 2.9  91/06/08  06:00:22  brennan
  39.  * changed how eof is marked on main_fin
  40.  * 
  41.  * Revision 2.8  91/06/03  07:47:56  brennan
  42.  * added a TEST2 to bi_substr (will I ever get it right?)
  43.  * 
  44.  * Revision 2.7  91/05/16  12:19:23  brennan
  45.  * cleanup of machine dependencies
  46.  * 
  47.  * Revision 2.6  91/05/06  15:00:37  brennan
  48.  * flush output before fork
  49.  * 
  50.  * Revision 2.5  91/04/29  07:45:00  brennan
  51.  * plugged big memory leak and fixed small bozo in bi_substr
  52.  * plugged small memory leak in gsub()
  53.  * 
  54.  * Revision 2.4  91/04/26  06:59:41  brennan
  55.  * use builtin random number generator for portability
  56.  * 
  57.  * Revision 2.3  91/04/17  06:34:00  brennan
  58.  * index("","") should be 1 not 0 for consistency with match("",//)
  59.  * 
  60.  * Revision 2.2  91/04/09  12:38:42  brennan
  61.  * added static to funct decls to satisfy STARDENT compiler
  62.  * 
  63.  * Revision 2.1  91/04/08  08:22:17  brennan
  64.  * VERSION 0.97
  65.  * 
  66. */
  67.  
  68.  
  69. #include "mawk.h"
  70. #include "bi_funct.h"
  71. #include "bi_vars.h"
  72. #include "memory.h"
  73. #include "init.h"
  74. #include "files.h"
  75. #include "fin.h"
  76. #include "field.h"
  77. #include "regexp.h"
  78. #include "repl.h"
  79. #include <math.h>
  80.  
  81.  
  82. /* statics */
  83. static STRING *PROTO(gsub, (PTR, CELL *, char *, int) ) ;
  84. static void  PROTO( fplib_err, (char *, double, char *) ) ;
  85.  
  86.  
  87. /* global for the disassembler */
  88. BI_REC  bi_funct[] = { /* info to load builtins */
  89.  
  90. "index" , bi_index , 2, 2 ,
  91. "substr" , bi_substr, 2, 3,
  92. "sprintf" , bi_sprintf, 1, 255,
  93. "sin", bi_sin , 1, 1 ,
  94. "cos", bi_cos , 1, 1 ,
  95. "atan2", bi_atan2, 2,2,
  96. "exp", bi_exp, 1, 1,
  97. "log", bi_log , 1, 1 ,
  98. "int", bi_int, 1, 1,
  99. "sqrt", bi_sqrt, 1, 1,
  100. "rand" , bi_rand, 0, 0,
  101. "srand", bi_srand, 0, 1,
  102. "close", bi_close, 1, 1,
  103. "system", bi_system, 1, 1,
  104.  
  105. #if  MSDOS   /* this might go away, when pipes and system are added
  106.               for MSDOS  */
  107. "errmsg", bi_errmsg, 1, 1,
  108. #endif
  109.  
  110. #ifdef THINK_C    /* I doubt this will ever go away for the Macintosh
  111.            Toy Operating System */
  112. "errmsg", bi_errmsg, 1, 1,
  113. #endif
  114.  
  115. (char *) 0, (PF_CP) 0, 0, 0 } ;
  116.  
  117.  
  118.  
  119. void bi_funct_init()
  120. { register BI_REC *p = bi_funct ;
  121.   register SYMTAB *stp ;
  122.  
  123.   while ( p->name )
  124.   { stp = insert( p->name ) ;
  125.     stp->type = ST_BUILTIN ;
  126.     stp->stval.bip = p++ ;
  127.   }
  128.   /* seed rand() off the clock */
  129.   { CELL c ;
  130.  
  131.     c.type = 0 ; (void) bi_srand(&c) ;
  132.   }
  133.  
  134.   stp = insert( "length") ;
  135.   stp->type = ST_LENGTH ;
  136. }
  137.  
  138. /**************************************************
  139.  string builtins (except split (in split.c) and [g]sub (at end))
  140.  **************************************************/
  141.  
  142. CELL *bi_length(sp)
  143.   register  CELL *sp ;
  144. { unsigned len ;
  145.  
  146.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  147.   len = string(sp)->len ;
  148.  
  149.   free_STRING( string(sp) ) ;
  150.   sp->type = C_DOUBLE ;
  151.   sp->dval = (double) len ;
  152.  
  153.   return sp ;
  154. }
  155.  
  156. char *str_str(target, key , key_len)
  157.   register char *target, *key ;
  158.   unsigned key_len ;
  159. { 
  160.   switch( key_len )
  161.   { case 0 :  return (char *) 0 ;
  162.     case 1 :  return strchr( target, *key) ;
  163.     case 2 :
  164.         while ( target = strchr(target, *key) )
  165.           if ( target[1] == key[1] )  return  target ;
  166.           else target++ ;
  167.         /*failed*/
  168.         return (char *) 0 ;
  169.   }
  170.   key_len-- ;
  171.   while ( target = strchr(target, *key) )
  172.         if ( memcmp(target+1, key+1, SIZE_T(key_len)) == 0 ) return target ;
  173.         else target++ ;
  174.   /*failed*/
  175.   return (char *) 0 ;
  176. }
  177.  
  178.  
  179.  
  180. CELL *bi_index(sp)
  181.   register CELL *sp ;
  182. { register int idx ;
  183.   unsigned len ;
  184.   char *p ;
  185.  
  186.   sp-- ;
  187.   if ( TEST2(sp) != TWO_STRINGS )
  188.         cast2_to_s(sp) ;
  189.  
  190.   if ( len = string(sp+1)->len )
  191.     idx = (p = str_str(string(sp)->str,string(sp+1)->str,len))
  192.           ? p - string(sp)->str + 1 : 0 ;
  193.  
  194.   else  /* index of the empty string */
  195.     idx = 1 ;
  196.   
  197.   free_STRING( string(sp) ) ;
  198.   free_STRING( string(sp+1) ) ;
  199.   sp->type = C_DOUBLE ;
  200.   sp->dval = (double) idx ;
  201.   return sp ;
  202. }
  203.  
  204. /*  substr(s, i, n)
  205.     if l = length(s)
  206.     then get the characters
  207.     from  max(1,i) to min(l,n-i-1) inclusive */
  208.  
  209. CELL *bi_substr(sp)
  210.   CELL *sp ;
  211. { int n_args, len ;
  212.   register int i, n ;
  213.   STRING *sval ;  /* substr(sval->str, i, n) */
  214.  
  215.   n_args = sp->type ;
  216.   sp -= n_args ;
  217.   if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  218.       /* don't use < C_STRING shortcut */
  219.   sval = string(sp) ;
  220.  
  221.   if ( (len = sval->len) == 0 )  /* substr on null string */
  222.   {  if ( n_args == 3 )  cell_destroy(sp+2) ;
  223.      cell_destroy(sp+1) ;
  224.      return sp ;
  225.   }
  226.  
  227.   if ( n_args == 2 )  
  228.   { n = 0x7fff  ;  /* essentially infinity */
  229.     if ( sp[1].type != C_DOUBLE ) cast1_to_d(sp+1) ; 
  230.   }
  231.   else
  232.   { if ( TEST2(sp+1) != TWO_DOUBLES ) cast2_to_d(sp+1) ;
  233.     n = (int) sp[2].dval ;
  234.   }
  235.   i = (int) sp[1].dval - 1 ; /* i now indexes into string */
  236.  
  237.   if ( i < 0 ) { n += i ; i = 0 ; }
  238.   if ( n > len - i )  n = len - i ;
  239.  
  240.   if ( n <= 0 )  /* the null string */
  241.   { 
  242.     sp->ptr = (PTR) &null_str ;
  243.     null_str.ref_cnt++ ;
  244.   }
  245.   else  /* got something */
  246.   { 
  247.     sp->ptr = (PTR) new_STRING((char *)0, n) ;
  248.     (void) memcpy(string(sp)->str, sval->str + i, SIZE_T(n)) ;
  249.   }
  250.  
  251.   free_STRING(sval) ;
  252.   return sp ;
  253. } 
  254.  
  255. /*
  256.   match(s,r)
  257.   sp[0] holds r, sp[-1] holds s
  258. */
  259.  
  260. CELL *bi_match(sp)
  261.   register CELL *sp ;
  262. { 
  263.   char *p ;
  264.   unsigned length ;
  265.  
  266.   if ( sp->type != C_RE )  cast_to_RE(sp) ;
  267.   if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;
  268.  
  269.   cell_destroy( & bi_vars[RSTART] ) ;
  270.   cell_destroy( & bi_vars[RLENGTH] ) ;
  271.   bi_vars[RSTART].type = C_DOUBLE ;
  272.   bi_vars[RLENGTH].type = C_DOUBLE ;
  273.  
  274.   p = REmatch(string(sp)->str, (sp+1)->ptr, &length) ;
  275.  
  276.   if ( p )
  277.   { sp->dval = (double) ( p - string(sp)->str + 1 ) ;
  278.     bi_vars[RLENGTH].dval = (double) length ;
  279.   }
  280.   else
  281.   { sp->dval = 0.0 ;
  282.     bi_vars[RLENGTH].dval = -1.0 ; /* posix */
  283.   }
  284.  
  285.   free_STRING(string(sp)) ;
  286.   sp->type = C_DOUBLE ;
  287.  
  288.   bi_vars[RSTART].dval = sp->dval ;
  289.  
  290.   return sp ;
  291. }
  292.  
  293.  
  294. /************************************************
  295.   arithemetic builtins
  296.  ************************************************/
  297.  
  298. static void fplib_err( fname, val, error)
  299.   char *fname ;
  300.   double val ;
  301.   char *error ;
  302. {
  303.   rt_error("%s(%g) : %s" , fname, val, error) ;
  304. }
  305.  
  306.  
  307. CELL *bi_sin(sp)
  308.   register CELL *sp ;
  309. { 
  310. #if ! STDC_MATHERR
  311.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  312.   sp->dval = sin( sp->dval ) ;
  313.   return sp ;
  314. #else
  315.   double x ;
  316.  
  317.   errno = 0 ;
  318.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  319.   x = sp->dval ;
  320.   sp->dval = sin( sp->dval ) ;
  321.   if ( errno )  fplib_err("sin", x, "loss of precision") ;
  322.   return sp ;
  323. #endif
  324. }
  325.  
  326. CELL *bi_cos(sp)
  327.   register CELL *sp ;
  328. { 
  329. #if ! STDC_MATHERR
  330.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  331.   sp->dval = cos( sp->dval ) ;
  332.   return sp ;
  333. #else
  334.   double x ;
  335.  
  336.   errno = 0 ;
  337.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  338.   x = sp->dval ;
  339.   sp->dval = cos( sp->dval ) ;
  340.   if ( errno )  fplib_err("cos", x, "loss of precision") ;
  341.   return sp ;
  342. #endif
  343. }
  344.  
  345. CELL *bi_atan2(sp)
  346.   register CELL *sp ;
  347. { 
  348. #if  !  STDC_MATHERR
  349.   sp-- ;
  350.   if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  351.   sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  352.   return sp ;
  353. #else
  354.  
  355.   errno = 0 ;
  356.   sp-- ;
  357.   if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  358.   sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  359.   if ( errno ) rt_error("atan2(0,0) : domain error") ;
  360.   return sp ;
  361. #endif
  362. }
  363.  
  364. CELL *bi_log(sp)
  365.   register CELL *sp ;
  366. { 
  367. #if ! STDC_MATHERR
  368.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  369.   sp->dval = log( sp->dval ) ;
  370.   return sp ;
  371. #else
  372.   double  x ;
  373.  
  374.   errno = 0 ;
  375.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  376.   x = sp->dval ;
  377.   sp->dval = log( sp->dval ) ;
  378.   if ( errno )  fplib_err("log", x, "domain error") ;
  379.   return sp ;
  380. #endif
  381. }
  382.  
  383. CELL *bi_exp(sp)
  384.   register CELL *sp ;
  385. { 
  386. #if  ! STDC_MATHERR
  387.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  388.   sp->dval = exp(sp->dval) ;
  389.   return sp ;
  390. #else
  391.   double  x ;
  392.  
  393.   errno = 0 ;
  394.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  395.   x = sp->dval ;
  396.   sp->dval = exp(sp->dval) ;
  397.   if ( errno && sp->dval)  fplib_err("exp", x, "overflow") ;
  398.      /* on underflow sp->dval==0, ignore */
  399.   return sp ;
  400. #endif
  401. }
  402.  
  403. CELL *bi_int(sp)
  404.   register CELL *sp ;
  405. { if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  406.   sp->dval = sp->dval >= 0.0 ? floor( sp->dval ) : ceil(sp->dval)  ;
  407.   return sp ;
  408. }
  409.  
  410. CELL *bi_sqrt(sp)
  411.   register CELL *sp ;
  412. { 
  413. #if  ! STDC_MATHERR
  414.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  415.   sp->dval = sqrt( sp->dval ) ;
  416.   return sp ;
  417. #else
  418.   double x ;
  419.  
  420.   errno = 0 ;
  421.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  422.   x = sp->dval ;
  423.   sp->dval = sqrt( sp->dval ) ;
  424.   if ( errno )  fplib_err("sqrt", x, "domain error") ;
  425.   return sp ;
  426. #endif
  427. }
  428.  
  429. #ifdef  __TURBOC__
  430. long  biostime(int, long) ;
  431. #define  time(x)  biostime(0,0L)
  432. #else
  433. #ifdef THINK_C
  434. #include <time.h>
  435. #else
  436. #include <sys/types.h>
  437. #endif
  438. #endif
  439.  
  440.  
  441. /* For portability, we'll use our own random number generator , taken
  442.    from:  Park, SK and Miller KW, "Random Number Generators:
  443.    Good Ones are Hard to Find", CACM, 31, 1192-1201, 1988.
  444. */
  445.  
  446. static long seed ;  /* must be >=1 and <= 2^31-1 */
  447. static CELL cseed ; /* argument of last call to srand() */
  448.  
  449. #define         M       0x7fffffff   /* 2^31-1 */
  450.  
  451. CELL *bi_srand(sp)
  452.   register CELL *sp ;
  453. { CELL c ;
  454.  
  455.   if ( sp->type == 0 ) /* seed off clock */
  456.   { (void) cellcpy(sp, &cseed) ;
  457.     cell_destroy(&cseed) ;
  458.     cseed.type = C_DOUBLE ;
  459.     cseed.dval = (double) time((time_t*) 0) ;
  460.   }
  461.   else /* user seed */
  462.   { sp-- ;
  463.     /* swap cseed and *sp ; don't need to adjust ref_cnts */
  464.     c = *sp ; *sp = cseed ; cseed = c ;
  465.   }
  466.  
  467.   /* The old seed is now in *sp ; move the value in cseed to
  468.      seed in range 1 to M */
  469.  
  470.   (void) cellcpy(&c, &cseed) ;
  471.   if ( c.type == C_NOINIT )  cast1_to_d(&c) ;
  472.  
  473.   seed =  c.type == C_DOUBLE ? ((int)c.dval & M) % M + 1 :
  474.                         hash(string(&c)->str) % M + 1 ;
  475.  
  476.   cell_destroy(&c) ;
  477.  
  478.   /* crank it once so close seeds don't give a close 
  479.        first result  */
  480. #define   A     16807
  481. #define   Q     127773   /* M/A */
  482. #define   R     2836     /* M%A */
  483.   seed = A * (seed%Q) - R * (seed/Q) ;
  484.   if ( seed <= 0 )  seed += M ;
  485.  
  486.   return sp ;
  487. }
  488.     
  489. CELL *bi_rand(sp)
  490.   register CELL *sp ;
  491. { 
  492.   register long test ;
  493.  
  494.   test = A * (seed%Q) - R * (seed/Q) ;
  495.   if ( test <= 0 )  test += M ;
  496.  
  497.   (++sp)->type = C_DOUBLE ;
  498.   sp->dval = (double)( seed = test ) / (double) M ;
  499.   return sp ;
  500.  
  501. #undef   A
  502. #undef   M
  503. #undef   Q
  504. #undef   R
  505. }
  506.  
  507. /*************************************************
  508.  miscellaneous builtins
  509.  close, system and getline
  510.  *************************************************/
  511.  
  512. CELL *bi_close(sp)
  513.   register CELL *sp ;
  514. { int x ;
  515.  
  516.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  517.   x = file_close( (STRING *) sp->ptr) ;
  518.   free_STRING( string(sp) ) ;
  519.   sp->type = C_DOUBLE ;
  520.   sp->dval = (double) x ;
  521.   return sp ;
  522. }
  523.  
  524. #if   ! MSDOS
  525. #ifndef THINK_C
  526. CELL *bi_system(sp)
  527.   CELL *sp ;
  528. { int pid ;
  529.   unsigned ret_val ;
  530.  
  531.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  532.  
  533.   fflush(stdout) ; fflush(stderr) ;
  534.  
  535.   switch( pid = fork() )
  536.   { case -1 :  /* fork failed */
  537.  
  538.        errmsg(errno, "could not create a new process") ;
  539.        ret_val = 128 ;
  540.        break ;
  541.  
  542.     case  0  :  /* the child */
  543.        (void) execl(shell, shell, "-c", string(sp)->str, (char *) 0) ;
  544.        /* if get here, execl() failed */
  545.        errmsg(errno, "execute of %s failed", shell) ;
  546.        fflush(stderr) ;
  547.        _exit(128) ;
  548.  
  549.     default   :  /* wait for the child */
  550.        ret_val = wait_for(pid) ;
  551.        if ( ret_val & 0xff ) ret_val = 128 ;
  552.        else  ret_val = (ret_val & 0xff00) >> 8 ;
  553.        break ;
  554.   }
  555.  
  556.   cell_destroy(sp) ;
  557.   sp->type = C_DOUBLE ;
  558.   sp->dval = (double) ret_val ;
  559.   return sp ;
  560. }
  561.  
  562. #else   /* THINK_C */
  563.  
  564. CELL *bi_system( sp )
  565.   register CELL *sp ;
  566. { rt_error("no system call for the Macintosh Toy Operating System!!!") ;
  567.   return sp ;
  568. }
  569.  
  570. /* prints errmsgs for the Macintosh  */
  571. CELL *bi_errmsg(sp)
  572.   register CELL *sp ;
  573. {
  574.   cast1_to_s(sp) ;
  575.   fprintf(stderr, "%s\n", string(sp)->str) ;
  576.   free_STRING(string(sp)) ;
  577.   sp->type = C_DOUBLE ;
  578.   sp->dval = 0.0 ;
  579.   return sp ;
  580. }
  581.  
  582. #endif
  583. #else   /*  MSDOS   */
  584.  
  585. CELL *bi_system( sp )
  586.   register CELL *sp ;
  587. { rt_error("no system call in MsDos --yet") ;
  588.   return sp ;
  589. }
  590.  
  591. /* prints errmsgs for MSDOS  */
  592. CELL *bi_errmsg(sp)
  593.   register CELL *sp ;
  594. {
  595.   cast1_to_s(sp) ;
  596.   fprintf(stderr, "%s\n", string(sp)->str) ;
  597.   free_STRING(string(sp)) ;
  598.   sp->type = C_DOUBLE ;
  599.   sp->dval = 0.0 ;
  600.   return sp ;
  601. }
  602. #endif
  603.  
  604.  
  605. /*  getline()  */
  606.  
  607. /*  if type == 0 :  stack is 0 , target address
  608.  
  609.     if type == F_IN : stack is F_IN, expr(filename), target address
  610.  
  611.     if type == PIPE_IN : stack is PIPE_IN, target address, expr(pipename)
  612. */
  613.  
  614. CELL *bi_getline(sp)
  615.   register CELL *sp ;
  616. { 
  617.   CELL tc , *cp ;
  618.   char *p ;
  619.   unsigned len ;
  620.   FIN *fin_p ;
  621.  
  622.  
  623.   switch( sp->type )
  624.   { 
  625.     case 0 :
  626.         sp-- ;
  627.         if ( ! main_fin )  open_main() ;
  628.     
  629.         if ( ! (p = FINgets(main_fin, &len)) )
  630.                 goto  eof ;
  631.  
  632.         cp = (CELL *) sp->ptr ;
  633.         if ( TEST2(bi_vars+NR) != TWO_DOUBLES ) cast2_to_d(bi_vars+NR) ;
  634.         bi_vars[NR].dval += 1.0 ;
  635.         bi_vars[FNR].dval += 1.0 ;
  636.         break ;
  637.  
  638.     case  F_IN :
  639.         sp-- ;
  640.         if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  641.         fin_p = (FIN *) file_find(sp->ptr, F_IN) ;
  642.         free_STRING(string(sp) ) ;
  643.         sp-- ;
  644.  
  645.         if ( ! fin_p )   goto open_failure ;
  646.         if ( ! (p = FINgets(fin_p, &len)) )  goto eof ; 
  647.         cp = (CELL *) sp->ptr ;
  648.         break ;
  649.  
  650.     case PIPE_IN :
  651.         sp -= 2 ;
  652.         if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  653.         fin_p = (FIN *) file_find(sp->ptr, PIPE_IN) ;
  654.         free_STRING(string(sp)) ;
  655.  
  656.         if ( ! fin_p )   goto open_failure ;
  657.         if ( ! (p = FINgets(fin_p, &len)) )  goto eof ; 
  658.         cp = (CELL *) (sp+1)->ptr ;
  659.         break ;
  660.  
  661.     default : bozo("type in bi_getline") ;
  662.  
  663.   }
  664.  
  665.   /* we've read a line , store it */
  666.  
  667.     if ( len == 0 )
  668.     { tc.type = C_STRING ; 
  669.       tc.ptr = (PTR) &null_str ; 
  670.       null_str.ref_cnt++ ;
  671.     }
  672.     else
  673.     { tc.type = C_MBSTRN ;
  674.       tc.ptr = (PTR) new_STRING((char *) 0, len) ;
  675.       (void) memcpy( string(&tc)->str, p, SIZE_T(len)) ;
  676.     }
  677.  
  678.     if ( cp  >= field && cp < field+NUM_FIELDS )
  679.            field_assign(cp-field, &tc) ;
  680.     else
  681.     { cell_destroy(cp) ;
  682.       (void) cellcpy(cp, &tc) ;
  683.     }
  684.  
  685.     cell_destroy(&tc) ;
  686.  
  687.   sp->dval = 1.0  ;  goto done ;
  688.  
  689. open_failure :
  690.   sp->dval = -1.0  ; goto done ;
  691.  
  692. eof :
  693.   sp->dval = 0.0  ;  /* fall thru to done  */
  694.  
  695. done :
  696.   sp->type = C_DOUBLE  ;
  697.   return sp ;
  698. }
  699.  
  700. /**********************************************
  701.  sub() and gsub()
  702.  **********************************************/
  703.  
  704. /* entry:  sp[0] = address of CELL to sub on
  705.            sp[-1] = substitution CELL
  706.            sp[-2] = regular expression to match
  707. */
  708.  
  709. CELL *bi_sub( sp )
  710.   register CELL *sp ;
  711. { CELL *cp ; /* pointer to the replacement target */
  712.   CELL tc ;  /* build the new string here */
  713.   CELL sc ;  /* copy of the target CELL */
  714.   char *front, *middle, *back ; /* pieces */
  715.   unsigned front_len, middle_len, back_len ;
  716.  
  717.   sp -= 2 ;
  718.   if ( sp->type != C_RE )  cast_to_RE(sp) ;
  719.   if ( sp[1].type != C_REPL && sp[1].type != C_REPLV )
  720.               cast_to_REPL(sp+1) ;
  721.   cp = (CELL *) (sp+2)->ptr ;
  722.   /* make a copy of the target, because we won't change anything
  723.      including type unless the match works */
  724.   (void) cellcpy(&sc, cp) ;
  725.   if ( sc.type < C_STRING ) cast1_to_s(&sc) ;
  726.   front = string(&sc)->str ;
  727.  
  728.   if ( middle = REmatch(front, sp->ptr, &middle_len) )
  729.   { 
  730.     front_len = middle - front ;
  731.     back = middle + middle_len ; 
  732.     back_len = string(&sc)->len - front_len - middle_len ;
  733.  
  734.     if ( (sp+1)->type == C_REPLV ) 
  735.     { STRING *sval = new_STRING((char *) 0, middle_len) ;
  736.  
  737.       (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
  738.       (void) replv_to_repl(sp+1, sval) ;
  739.       free_STRING(sval) ;
  740.     }
  741.  
  742.     tc.type = C_STRING ;
  743.     tc.ptr = (PTR) new_STRING((char *) 0, 
  744.              front_len + string(sp+1)->len + back_len ) ;
  745.  
  746.     { char *p = string(&tc)->str ;
  747.  
  748.       if ( front_len )
  749.       { (void) memcpy(p, front, SIZE_T(front_len)) ;
  750.         p += front_len ;
  751.       }
  752.       if ( string(sp+1)->len )
  753.       { (void) memcpy(p, string(sp+1)->str, SIZE_T(string(sp+1)->len)) ;
  754.         p += string(sp+1)->len ;
  755.       }
  756.       if ( back_len )  (void) memcpy(p, back, SIZE_T(back_len)) ;
  757.     }
  758.  
  759.     if ( cp  >= field && cp < field+NUM_FIELDS )
  760.            field_assign(cp-field, &tc) ;
  761.     else
  762.     { cell_destroy(cp) ;
  763.       (void) cellcpy(cp, &tc) ;
  764.     }
  765.  
  766.     free_STRING(string(&tc)) ;
  767.   }
  768.  
  769.   free_STRING(string(&sc)) ;
  770.   repl_destroy(sp+1) ;
  771.   sp->type = C_DOUBLE ;
  772.   sp->dval = middle != (char *) 0 ? 1.0 : 0.0 ;
  773.   return sp ;
  774. }
  775.  
  776. static  unsigned repl_cnt ;  /* number of global replacements */
  777.  
  778. /* recursive global subsitution 
  779.    dealing with empty matches makes this mildly painful
  780. */
  781.  
  782. static STRING *gsub( re, repl, target, flag)
  783.   PTR  re ;
  784.   CELL *repl ;  /* always of type REPL or REPLV, 
  785.        destroyed by caller */
  786.   char *target ;
  787.   int flag ; /* if on, match of empty string at front is OK */
  788. { char *front, *middle ;
  789.   STRING *back ;
  790.   unsigned front_len, middle_len ;
  791.   STRING  *ret_val ;
  792.   CELL xrepl ; /* a copy of repl so we can change repl */
  793.  
  794.   if ( ! (middle = REmatch(target, re, &middle_len)) )
  795.       return  new_STRING(target) ; /* no match */
  796.  
  797.   (void) cellcpy(&xrepl, repl) ;
  798.  
  799.   if ( !flag && middle_len == 0 && middle == target ) 
  800.   { /* match at front that's not allowed */
  801.  
  802.     if ( *target == 0 )  /* target is empty string */
  803.     { repl_destroy(&xrepl) ;
  804.       null_str.ref_cnt++ ;
  805.       return & null_str ;
  806.     }
  807.     else
  808.     { char xbuff[2] ;
  809.  
  810.       front_len = 0 ;
  811.       /* make new repl with target[0] */
  812.       repl_destroy(repl) ;
  813.       xbuff[0] = *target++ ;  xbuff[1] = 0 ;
  814.       repl->type = C_REPL ;
  815.       repl->ptr = (PTR) new_STRING( xbuff ) ;
  816.       back = gsub(re, &xrepl, target, 1) ;
  817.     }
  818.   }
  819.   else  /* a match that counts */
  820.   { repl_cnt++ ;
  821.  
  822.     front = target ;
  823.     front_len = middle - target ;
  824.  
  825.     if ( *middle == 0 )  /* matched back of target */
  826.     { back = &null_str ; null_str.ref_cnt++ ; }
  827.     else back = gsub(re, &xrepl, middle + middle_len, 0) ;
  828.       
  829.     /* patch the &'s if needed */
  830.     if ( repl->type == C_REPLV )
  831.     { STRING *sval = new_STRING((char *) 0, middle_len) ;
  832.  
  833.       (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
  834.       (void) replv_to_repl(repl, sval) ;
  835.       free_STRING(sval) ;
  836.     }
  837.   }
  838.  
  839.   /* put the three pieces together */
  840.   ret_val = new_STRING((char *)0,
  841.               front_len + string(repl)->len + back->len); 
  842.   { char *p = ret_val->str ;
  843.  
  844.     if ( front_len )
  845.     { (void) memcpy(p, front, SIZE_T(front_len)) ; p += front_len ; }
  846.     if ( string(repl)->len )
  847.     { (void) memcpy(p, string(repl)->str, SIZE_T(string(repl)->len)) ;
  848.       p += string(repl)->len ;
  849.     }
  850.     if ( back->len ) (void) memcpy(p, back->str, SIZE_T(back->len)) ;
  851.   }
  852.  
  853.   /* cleanup, repl is freed by the caller */
  854.   repl_destroy(&xrepl) ;
  855.   free_STRING(back) ;
  856.  
  857.   return ret_val ;
  858. }
  859.  
  860. /* set up for call to gsub() */
  861. CELL *bi_gsub( sp )
  862.   register CELL *sp ;
  863. { CELL *cp ;  /* pts at the replacement target */
  864.   CELL sc  ;  /* copy of replacement target */
  865.   CELL tc  ;  /* build the result here */
  866.  
  867.   sp -= 2 ;
  868.   if ( sp->type != C_RE ) cast_to_RE(sp) ;
  869.   if ( (sp+1)->type != C_REPL && (sp+1)->type != C_REPLV )
  870.           cast_to_REPL(sp+1) ;
  871.  
  872.   (void) cellcpy(&sc, cp = (CELL *)(sp+2)->ptr) ;
  873.   if ( sc.type < C_STRING ) cast1_to_s(&sc) ;
  874.  
  875.   repl_cnt = 0 ;
  876.   tc.ptr = (PTR) gsub(sp->ptr, sp+1, string(&sc)->str, 1) ;
  877.  
  878.   if ( repl_cnt )
  879.   { tc.type = C_STRING ;
  880.  
  881.     if ( cp >= field && cp < field + NUM_FIELDS )
  882.         field_assign(cp-field, &tc) ;
  883.     else
  884.     { cell_destroy(cp) ; (void) cellcpy(cp, &tc) ; }
  885.   }
  886.  
  887.   /* cleanup */
  888.   free_STRING(string(&sc)) ; free_STRING(string(&tc)) ;
  889.   repl_destroy(sp+1) ;
  890.  
  891.   sp->type = C_DOUBLE ;
  892.   sp->dval = (double) repl_cnt ;
  893.   return sp ;
  894. }
  895.